home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Wimage2.stklos < prev    next >
Encoding:
Text File  |  1995-08-23  |  1.4 KB  |  41 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script displays two image widgets.
  5. ;;;;
  6. (require "Tk-classes")
  7.  
  8. (define image-directory *STk-images*)
  9.  
  10. (define (demo-image2)
  11.   (let* ((w   (make-demo-toplevel "image2"
  12.                   "Image Demonstration #2"
  13.                   "This demonstration allows you to view images using an Tk \"photo\" image.  First type a directory name in the listbox, then type Return to load the directory into the listbox.  Then double-click on a file name in the listbox to see that image."))
  14.      (dir (make <Entry> :parent w :width 30 :text-variable 'image-directory))
  15.      (lst (make <Scroll-listbox> :parent w 
  16.             :value '("earth.gif" "earthris.gif" "mickey.gif" "teapot.ppm")))
  17.      (img (make <Photo-Image>))
  18.      (lab (make <Label> :parent w :image img)))
  19.     
  20.     (pack (make <Label> :parent w :text "Directory:") 
  21.       dir 
  22.       (make <Label> :parent w :text "File:")
  23.       lst
  24.       (make <Label> :parent w :text "Image:")
  25.       lab
  26.       :side "top" :anchor "w")
  27.     
  28.     ;; Add binding to listbox and entry
  29.     (let ((lb (slot-ref lst 'listbox)))
  30.       (bind lb  "<Double-1>" 
  31.         (lambda ()
  32.           (let ((file (selection 'get)))
  33.         (slot-set! img 'file (string-append image-directory "/" file)))))
  34.  
  35.       (bind dir "<Return>" 
  36.         (lambda () 
  37.           (slot-set! lb 'value
  38.              (sort (map basename 
  39.                     (glob (string-append image-directory "/*")))
  40.                    string<?)))))))
  41.